PC World Interactive 7/PC World Interactive 7.iso/program/vbkontrol.exe/CSWSK10A.ZIP/tinyftp.bas

BASIC Source File | 1995-07-25 | 6.8 KB | 269 lines

Option Explicit

Function FTPCommand (CtlData As String) As Integer
    On Error Resume Next

    CtlData = CtlData & Chr$(13) & Chr$(10)
    Client.Socket1.SendLen = Len(CtlData)
    Client.Socket1.SendData = CtlData

    If Err <> 0 Then
        FTPCommand = False
    Else
        FTPCommand = True
    End If

End Function

Function FTPConnect (HostName As String)
    Dim CtlData As String, Reply As Integer

    FTPConnect = False
    If HostName = "" Then Exit Function

    Client.Socket1.AddressFamily = AF_INET
    Client.Socket1.Protocol = IPPROTO_IP
    Client.Socket1.Type = SOCK_STREAM
    Client.Socket1.RemotePort = IPPORT_FTP
    Client.Socket1.HostName = HostName
    Client.Socket1.Binary = False
    Client.Socket1.BufferSize = 1024
    Client.Socket1.Blocking = True

    On Error Resume Next
    Client.Socket1.Action = SOCKET_CONNECT
    If Err Then
        MsgBox Error$
        Exit Function
    End If

    Reply = FTPResult(CtlData)

    If Reply = 220 Then
        FTPConnect = True
    Else
        Client.Socket1.Action = SOCKET_CLOSE
    End If

End Function

Sub FTPGetDirectory ()
    Dim CtlData As String

    If Not FTPCommand("PWD") Then Exit Sub
    If FTPResult(CtlData) <> 257 Then Exit Sub

    CtlData = Mid$(CtlData, 2, InStr(CtlData, " ") - 3)
    Client.RemotePath.Caption = CtlData
End Sub

Function FTPGetFile (RemoteFile As String, LocalFile As String)
    Dim CtlData As String, Buffer As String
    Dim Result As Integer

    FTPGetFile = False

    If RemoteFile = "" Or LocalFile = "" Then Exit Function
    If Not FTPListen() Then Exit Function
    If Not FTPCommand("RETR " & RemoteFile) Then Exit Function

    If FTPResult(CtlData) <> 150 Then
        Client.Socket2.Action = SOCKET_CLOSE
        Exit Function
    End If

    Client.Socket2.Action = SOCKET_ACCEPT
    On Error Resume Next

    Open LocalFile For Binary As #1
    If Err Then
        MsgBox Error$
        Client.Socket2.Action = SOCKET_CLOSE
        Exit Function
    End If

    FTPGetFile = True

    Do
        Client.Socket2.RecvLen = 4096
        Buffer = Client.Socket2.RecvData
        If Err Then
            FTPGetFile = False
            MsgBox Error$
            Exit Do
        End If
        If Client.Socket2.RecvLen = 0 Then Exit Do
        Put #1, , Buffer
        DoEvents
    Loop

    Close #1
    Client.Socket2.Action = SOCKET_CLOSE
    Result = FTPResult(CtlData)
End Function

Function FTPListen ()
    Dim Port As Integer, Address As String
    Dim Reply As Integer, CtlData As String
    Dim I As Integer, P As Integer

    FTPListen = False

    Client.Socket2.AddressFamily = AF_INET
    Client.Socket2.Binary = True
    Client.Socket2.Blocking = True
    Client.Socket2.BufferSize = 0
    Client.Socket2.HostAddress = INADDR_ANY
    Client.Socket2.LocalPort = IPPORT_ANY
    Client.Socket2.Protocol = IPPROTO_TCP
    Client.Socket2.Timeout = 0
    Client.Socket2.Type = SOCK_STREAM
    Client.Socket2.Action = SOCKET_LISTEN

    Port = Client.Socket2.LocalPort
    Address = Client.Socket2.LocalAddress

    For I = 1 To 3
        P = InStr(Address, ".")
        If P <> 0 Then Mid$(Address$, P, 1) = ","
    Next I

    CtlData = "PORT " & Address & "," & (Port \ 256) & "," & (Port Mod 256)

    If Not FTPCommand(CtlData) Then GoTo OpenFailed
    If FTPResult(CtlData) <> 200 Then GoTo OpenFailed

    If Client.BinaryTransfer.Value = 1 Then
        CtlData = "TYPE I"
    Else
        CtlData = "TYPE A"
    End If

    If Not FTPCommand(CtlData) Then GoTo OpenFailed
    If FTPResult(CtlData) <> 200 Then GoTo OpenFailed

    FTPListen = True
    Exit Function

OpenFailed:
    If Client.Socket2.Listening Then Client.Socket2.Action = SOCKET_CLOSE
    Exit Function
End Function

Function FTPLogin (Username As String, Password As String) As Integer
    Dim CtlData As String, Reply As Integer
    Dim Counter As Integer

    FTPLogin = False

    If Client.Socket1.IsReadable Then
        Reply = FTPResult(CtlData)
    End If

    While Reply = 220 And Client.Socket1.IsReadable
        Reply = FTPResult(CtlData)
    Wend

    CtlData = "USER " & Username
    If Not FTPCommand(CtlData) Then Exit Function
    Reply = FTPResult(CtlData)

    If Reply = 331 Then
        CtlData = "PASS " & Password
        If Not FTPCommand(CtlData) Then Exit Function
        Reply = FTPResult(CtlData)
    End If

    While Reply = 230 And Client.Socket1.IsReadable
        Reply = FTPResult(CtlData)
    Wend

    If Reply = 230 Then
        FTPLogin = True
    Else
        MsgBox "Invalid user name or password"
    End If

End Function

Function FTPPutFile (LocalFile As String, RemoteFile As String)
    Dim CtlData As String, Buffer As String * 4096
    Dim Result As Integer, Size As Long

    FTPPutFile = False

    If RemoteFile = "" Or LocalFile = "" Then Exit Function
    If Not FTPListen() Then Exit Function
    If Not FTPCommand("STOR " & RemoteFile) Then Exit Function

    If FTPResult(CtlData) <> 150 Then
        Client.Socket2.Action = SOCKET_ABORT
        Exit Function
    End If

    Client.Socket2.Action = SOCKET_ACCEPT
    On Error Resume Next

    Size = FileLen(LocalFile)
    If Err Then
        Client.Socket2.Action = SOCKET_CLOSE
        MsgBox Error$
        Exit Function
    End If

    Open LocalFile For Binary As #1

    If Err Then
        Client.Socket2.Action = SOCKET_CLOSE
        MsgBox Error$
        Exit Function
    End If

    FTPPutFile = True

    Do
        Get #1, , Buffer
        If Size < Len(Buffer) Then
            Client.Socket2.SendLen = Size
            Size = 0
        Else
            Client.Socket2.SendLen = Len(Buffer)
            Size = Size - Len(Buffer)
        End If
        Client.Socket2.SendData = Buffer
        If Err > 0 Then
            FTPPutFile = False
            MsgBox Error$
            Exit Do
        End If
        If Size = 0 Then Exit Do
        DoEvents
    Loop

    Close #1
    Client.Socket2.Action = SOCKET_CLOSE
    Result = FTPResult(CtlData)
End Function

Function FTPResult (CtlData As String) As Integer
    Dim SockData As String, Reply As Integer

    Client.Socket1.RecvLen = 255
    SockData = Client.Socket1.RecvData
    Debug.Print SockData

    Reply = Val(Left$(SockData, 3))
    If Mid$(SockData, 4, 1) = "-" Then
        Do
            Client.Socket1.RecvLen = 255
            SockData = Client.Socket1.RecvData
            If Val(Left$(SockData, 3)) = Reply Then Exit Do
            Debug.Print SockData
        Loop
    End If
    CtlData = Right$(SockData, Len(SockData) - InStr(SockData, " "))

    FTPResult = Reply
End Function